home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / ARRAY.PRG next >
Encoding:
Text File  |  1993-12-14  |  45.1 KB  |  1,210 lines
  1. *-----------------------------------------------------------------------
  2. *-- Program...: ARRAY.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 07/30/1993
  5. *-- Notes.....: These routines deal with filling arrays, sorting arrays, 
  6. *--             and so on ... See README.TXT for details on using this 
  7. *--             file. 
  8. *-----------------------------------------------------------------------
  9.  
  10. FUNCTION Afill
  11. *-----------------------------------------------------------------------
  12. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  13. *-- Date........: 04/22/1992
  14. *-- Notes.......: Creates if needed, and fills a row or column of, an 
  15. *--               array, with sequential numeric elements starting with 
  16. *--               nFirst, increasing by nStep.
  17. *--               Useful for testing routines that require an array ...
  18. *-- Written for.: dBASE IV, 1.1
  19. *-- Rev. History: 03/01/1992 -- Original Release
  20. *--               04/22/1992 - Jay Parsons - calling syntax changed
  21. *-- Calls.......: AMASK()              Functon in ARRAY.PRG
  22. *-- Called by...: Any
  23. *-- Usage.......: AFill("<cArrayskel>",<nCount>,<nFirstVal>,<nStep>)
  24. *-- Example.....: lX = AFill("aTest",20,1,10)
  25. *-- Returns.....: .T. (and an array filled with values as in "notes" 
  26. *--                   above)
  27. *-- Parameters..: cArrayskel  = Name of array and optional row/column 
  28. *--                             info
  29. *--               nCount      = number of elements to fill
  30. *--               nFirstVal   = starting value in array
  31. *--               nStep       = number to increment by
  32. *-- Side effects: Creates as public, if needed, and fills array.  Will 
  33. *--               destroy existing array of the same name if its 
  34. *--               dimensions are inadequate for the data to be filled 
  35. *--               in.
  36. *-----------------------------------------------------------------------
  37.  
  38.    parameters cArrayskel, nCount, nFirstval, nStep
  39.    private nAt, cArray, cMask, cElem, nRows, nCols, nFill
  40.  
  41.    m->cArray = m->cArrayskel
  42.    if "[" $ m->cArray
  43.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  44.    endif
  45.    m->cArray = trim( ltrim( m->cArray ) )
  46.    m->cMask = Amask( m->cArrayskel, "nAt" )
  47.    if at( ",", m->cMask ) > 0 .and. val( substr( m->cMask, ;
  48.       at( ",", m->cMask ) + 1 ) ) = 0
  49.       m->nRows = val( substr( m->cMask, at( "[", m->cMask ) + 1 ) )
  50.       m->nCols = m->nCount
  51.    else
  52.       m->nRows = m->nCount
  53.       m->nCols = val( substr( m->cMask, at( ",", m->cMask ) + 1 ) )
  54.    endif
  55.    m->nAt = m->nCount
  56.    m->cElem = m->cArray + m->cMask
  57.    if type( m->cElem ) = "U"
  58.       release &cArray.
  59.       public &cArray.
  60.       if m->nCols > 0
  61.          declare &cArray.[ m->nRows, m->nCols ]
  62.       else
  63.          declare &cArray.[ m->nRows ]
  64.       endif
  65.    endif
  66.    m->nFill = m->nFirstVal
  67.    m->nAt = 0
  68.    do while m->nAt < m->nCount
  69.       m->nAt = m->nAt + 1
  70.       m->cElem = m->cArray + m->cMask
  71.       store m->nFill to &cElem.
  72.       m->nFill = m->nFill + m->nStep
  73.    enddo
  74.    
  75. RETURN .T.
  76. *-- EoF: Afill()
  77.  
  78. FUNCTION Amask
  79. *-----------------------------------------------------------------------
  80. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  81. *-- Date........: 04/21/1992
  82. *-- Notes.......: Returns a "mask" specifying the desired row or column 
  83. *--               of an array.
  84. *-- Written for.: dBASE IV
  85. *-- Rev. History: 04/21/1992 -- Original Release
  86. *-- Calls.......: None
  87. *-- Called by...: Any
  88. *-- Usage.......: Amask( <cArrayskel>, <cVar> )
  89. *-- Example.....: ? Amask( "Myarray [ , 1 ]", "nAt" )
  90. *-- Returns.....: A character value including a passed character string,
  91. *--               which may be used by the calling function to locate 
  92. *--               array elements
  93. *-- Parameters..: cArrayskel = a character string including the name of 
  94. *--                            the array and, if the row or column to 
  95. *--                            be used is not the first row (or only 
  96. *--                            row if array is one-dimensional), a 
  97. *--                            bracketed expression with a number 
  98. *--                            indicating the row, or column if the 
  99. *--                            number is preceded by a comma, to be 
  100. *--                            used.
  101. *--               cVar       = name of the memvar to be used by calling 
  102. *--                            function.
  103. *-----------------------------------------------------------------------
  104.  
  105.    parameters cArrayskel, cVar
  106.    private nAt, cWhich, cMask, cV
  107.  
  108.    m->nAt = at( "[", m->cArrayskel )
  109.    m->cWhich = "0 ]"
  110.    m->cV = trim( ltrim( m->cVar ) )
  111.    if m->nAt > 0
  112.       m->cWhich = substr( m->cArrayskel, m->nAt + 1 )
  113.    else
  114.       m->cWhich = "1 ]"
  115.    endif
  116.    if .not. "," $ m->cArrayskel
  117.       m->cMask = "[ " + m->cV + " ]"
  118.    else
  119.       if val( m->cWhich ) > 0
  120.     m->cMask = "["+ ltrim( str( val( m->cWhich ) ) ) + "," +;
  121.                 m->cV + "]"
  122.       else
  123.          m->cWhich = substr( m->cWhich, at( ",", m->cWhich ) + 1 )
  124.     m->cMask = "[" + m->cV+ ","+ ltrim( str( val( m->cWhich ) ) ) ;
  125.                            + "]"
  126.       endif
  127.    endif
  128.  
  129. RETURN m->cMask
  130. *-- EoF: Amask()
  131.  
  132. FUNCTION Amean
  133. *-----------------------------------------------------------------------
  134. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  135. *-- Date........: 04/13/1992
  136. *-- Notes.......: Mean of non-blank numeric or date values in specified 
  137. *--               row or column of a specified array.  If the first 
  138. *--               value is a date, averages only dates.  If first value
  139. *--               is numeric or float, averages only numerics and 
  140. *--               floats.  Exits returning .F. if first value is 
  141. *--               character or logical, if specified row or column does
  142. *--               not exist or if there are no averageable values.
  143. *-- Written for.: dBASE IV Version 1.5.
  144. *-- Rev. History: Original function written 1990
  145. *--             : Adapted to Version 1.5 4/13/1992
  146. *-- Calls.......: AMASK()              Function in ARRAY.PRG
  147. *-- Called by...: Any
  148. *-- Usage.......: Amean( <cArrayskel> )
  149. *-- Example.....: ? Amean( "Myarray [ , 1 ]" )
  150. *-- Returns.....: A numeric, float or date value, the mean or average, 
  151. *--               or .F. If any of the averaged items are floats, the 
  152. *--               result will be.
  153. *-- Parameters..: cArrayskel = a character string including the name of 
  154. *--                            the array and, if the row or column to 
  155. *--                            be averaged is not the first row, a 
  156. *--                            bracketed expression with a number 
  157. *--                            indicating the row, or column if the 
  158. *--                            number is preceded by a comma, to be 
  159. *--                            averaged.
  160. *-----------------------------------------------------------------------
  161.  
  162.    parameters cArrayskel
  163.    private nAt,cArray,cMask,cElem,nTot,nCount,xNext,cOktype
  164.  
  165.    m->cArray = m->cArrayskel
  166.    if "[" $ m->cArray
  167.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  168.    endif
  169.    m->cArray = trim( ltrim( m->cArray ) )
  170.    m->cMask = Amask( m->cArrayskel, "nAt" )
  171.    store 0 to m->nTot, m->nCount, m->nAt
  172.    do while .t.
  173.       m->nAt = m->nAt + 1
  174.       m->cElem = m->cArray + m->cMask
  175.       m->xNext = type( m->cElem )
  176.       do case
  177.          case m->xNext = "U"
  178.             exit
  179.          case m->nAt = 1
  180.             if m->xNext $ "CL"
  181.                exit
  182.             else
  183.                m->cOKType = iif( m->xNext = "D", "D", "NF" )
  184.             endif
  185.          case .not. m->xNext $ m->cOKType
  186.             loop
  187.       endcase
  188.       m->xNext = &cElem.
  189.       if isblank( m->xNext )
  190.          loop
  191.       endif
  192.       if m->cOKType = "D"
  193.          m->xNext = m->xNext - {01/01/01}
  194.       endif
  195.       m->nTot = m->nTot + m->xNext
  196.       m->nCount = m->nCount + 1
  197.    enddo
  198.  
  199. RETURN iif( m->nCount = 0, .F., m->nTot / m->nCount ;
  200.      + iif( m->cOKType = "D", {01/01/01}, 0 ) )
  201. *-- EoF: Amean()
  202.  
  203. FUNCTION Amax
  204. *-----------------------------------------------------------------------
  205. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  206. *-- Date........: 04/13/1992
  207. *-- Notes.......: Finds maximum non-blank numeric, date or character 
  208. *--               value in specified row or column of a specified array.
  209. *--               If the first value is character or date, considers 
  210. *--               only that type. If first value is numeric or float, 
  211. *--               considers only numerics and floats.  Exits returning
  212. *--               .F. if first value is logical, if specified row or 
  213. *--               column does not exist or if there are no numeric, 
  214. *--               date or character values in the row or column. 
  215. *-- Written for.: dBASE IV Version 1.5.
  216. *-- Rev. History: Original function written 1990
  217. *--             : Adapted to Version 1.5 4/13/1992
  218. *-- Calls.......: AMASK()              Function in ARRAY.PRG
  219. *-- Called by...: Any
  220. *-- Usage.......: Amax( <cArrayskel> )
  221. *-- Example.....: ? Amax( "Myarray [ , 1 ]" )
  222. *-- Returns.....: A char, numeric, float or date value, the maximum, 
  223. *--               or .F. If any of the numeric items are floats, the 
  224. *--               result will be.
  225. *-- Parameters..: cArrayskel = a character string including the name of 
  226. *--                            the array and, if the row or column to be
  227. *--                            used is not the first row, a bracketed
  228. *--                            expression with a number indicating the 
  229. *--                            row, or column if the number is preceded 
  230. *--                            by a comma, to be used.
  231. *-----------------------------------------------------------------------
  232.  
  233.    parameters cArrayskel
  234.    private nAt,cArray,cMask,cElem,xMax,xNext,cOktype
  235.  
  236.    m->cArray = m->cArrayskel
  237.    if "[" $ m->cArray
  238.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  239.    endif
  240.    m->cArray = trim( ltrim( m->cArray ) )
  241.    m->cMask = Amask( m->cArrayskel, "m->nAt" )
  242.    store 0 to m->nAt
  243.    do while .T.
  244.       m->nAt = m->nAt + 1
  245.       m->cElem = m->cArray + m->cMask
  246.       m->xNext = type( m->cElem )
  247.       do case
  248.          case m->xNext = "U"
  249.             exit
  250.          case m->nAt = 1
  251.             if m->xNext ="L"
  252.                exit
  253.             else
  254.                m->cOKType = iif( m->xNext $ "CD", m->xNext, "NF" )
  255.             endif
  256.          case .not. m->xNext $ m->cOKType
  257.             loop
  258.       endcase
  259.       m->xNext = &cElem.
  260.       if m->cOKType # "C" .and. isblank( m->xNext )
  261.          loop
  262.       endif
  263.       if m->nAt = 1
  264.          m->xMax = m->xNext
  265.       else
  266.          m->xMax = max( m->xMax, m->xNext )
  267.       endif
  268.    enddo
  269.  
  270. RETURN iif( type( "xMax" ) = "U", .F., m->xMax )
  271. *-- EoF: Amax()
  272.  
  273. FUNCTION Amin
  274. *-----------------------------------------------------------------------
  275. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  276. *-- Date........: 04/13/1992
  277. *-- Notes.......: Finds minimum non-blank numeric, date or character 
  278. *--               value in specified row or column of a specified array.
  279. *--               If the first value is character or date, considers 
  280. *--               only that type. If first value is numeric or float, 
  281. *--               considers only numerics and floats.  Exits returning 
  282. *--               .F. if first value is logical, if specified row or 
  283. *--               column does not exist or if there are no numeric, 
  284. *--               date or character values in the row or column.
  285. *-- Written for.: dBASE IV Version 1.5.
  286. *-- Rev. History: Original function written 1990
  287. *--             : Adapted to Version 1.5 4/13/1992
  288. *-- Calls.......: AMASK()                 Function in ARRAY.PRG
  289. *-- Called by...: Any
  290. *-- Usage.......: Amin( <cArrayskel> )
  291. *-- Example.....: ? Amin( "Myarray [ , 1 ]" )
  292. *-- Returns.....: A char, numeric, float or date value, the minimum, 
  293. *--               or .F. If any of the numeric items are floats, 
  294. *--               the result will be.
  295. *-- Parameters..: cArrayskel = A character string including the name of 
  296. *--                            the array and, if the row or column to be
  297. *--                            used is not the first row, a bracketed 
  298. *--                            expression with a number indicating the 
  299. *--                            row, or column if the number is preceded 
  300. *--                            by a comma, to be used.
  301. *-----------------------------------------------------------------------
  302.  
  303.    parameters cArrayskel
  304.    private nAt,cArray,cMask,m->cElem,xMin,xNext,cOktype
  305.  
  306.    m->cArray = m->cArrayskel
  307.    if "[" $ m->cArray
  308.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  309.    endif
  310.    m->cArray = trim( ltrim( m->cArray ) )
  311.    m->cMask = Amask( m->cArrayskel, "nAt" )
  312.    store 0 to m->nAt
  313.    do while .T.
  314.       m->nAt = m->nAt + 1
  315.       m->cElem = m->cArray + m->cMask
  316.       m->xNext = type( m->cElem )
  317.       do case
  318.          case m->xNext = "U"
  319.             exit
  320.          case m->nAt = 1
  321.             if m->xNext ="L"
  322.                exit
  323.             else
  324.                m->cOKType = iif( m->xNext $ "CD", m->xNext, "NF" )
  325.             endif
  326.          case .not. m->xNext $ m->cOKType
  327.             loop
  328.       endcase
  329.       m->xNext = &cElem.
  330.       if m->cOKType # "C" .and. isblank( m->xNext )
  331.          loop
  332.       endif
  333.       if m->nAt = 1
  334.          m->xMin = m->xNext
  335.       else
  336.          m->xMin = min( m->xMin, m->xNext )
  337.       endif
  338.    enddo
  339.  
  340. RETURN iif( type( "xMin" ) = "U", .F., m->xMin )
  341. *-- EoF: Amin()
  342.  
  343. FUNCTION Avar
  344. *-----------------------------------------------------------------------
  345. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  346. *-- Date........: 04/13/1992
  347. *-- Notes.......: Finds population variance of non-blank numeric or date
  348. *--               values in specified row or column of a specified 
  349. *--               array.  If first value is date, considers only that 
  350. *--               type. If first value is numeric or float, considers 
  351. *--               only numerics and floats.  Exits returning .F. if 
  352. *--               first value is character or logical, if specified 
  353. *--               row or column does not exist or if there are no 
  354. *--               numeric or date values in the row or column.
  355. *--             
  356. *--               To adapt this to find the sample variance, substitute
  357. *--               "( nCount - 1 )" for the final "nCount" in the last 
  358. *--               line. 
  359. *-- Written for.: dBASE IV Version 1.5.
  360. *-- Rev. History: Original function written 1990
  361. *--               Adapted to Version 1.5 4/13/1992
  362. *-- Calls.......: AMASK()                 Function in ARRAY.PRG
  363. *-- Called by...: Any
  364. *-- Usage.......: Avar( <cArrayskel> )
  365. *-- Example.....: ? Avar( "Myarray [ , 1 ]" )
  366. *-- Returns.....: A numeric, or float value, the variance, or .F. If 
  367. *--               any of the numeric items are floats, the result will 
  368. *--               be.
  369. *-- Parameters..: cArrayskel = a character string including the name of 
  370. *--                            the array and, if the row or column to 
  371. *--                            be used is not the first row, a bracketed
  372. *--                            expression with a number indicating the 
  373. *--                            row, or column if the number is preceded 
  374. *--                            by a comma, to be used.
  375. *-----------------------------------------------------------------------
  376.  
  377.    parameters cArrayskel
  378.    private nAt,cArray,cMask,cElem,nCount,nTot,nTotsq,xNext,cOktype
  379.  
  380.    m->cArray = m->cArrayskel
  381.    if "[" $ m->cArray
  382.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  383.    endif
  384.    m->cArray = trim( ltrim( m->cArray ) )
  385.    m->cMask = Amask( m->cArrayskel, "nAt" )
  386.    store 0 to m->nTot, m->nTotsq, m->nCount, m->nAt
  387.    do while .t.
  388.       m->nAt = m->nAt + 1
  389.       m->cElem = m->cArray + m->cMask
  390.       m->xNext = type( m->cElem )
  391.       do case
  392.          case m->xNext = "U"
  393.             exit
  394.          case m->nAt = 1
  395.             if m->xNext $ "CL"
  396.                exit
  397.             else
  398.                m->cOKType = iif( m->xNext = "D", "D", "NF" )
  399.             endif
  400.          case .not. m->xNext $ m->cOKType
  401.             loop
  402.       endcase
  403.       m->xNext = &cElem.
  404.       if isblank( m->xNext )
  405.          loop
  406.       endif
  407.       if m->cOKType = "D"
  408.          m->xNext = m->xNext - {01/01/01}
  409.       endif
  410.       m->nTot = m->nTot + m->xNext
  411.       m->nTotsq = m->nTotsq + m->xNext * m->xNext
  412.       m->nCount = m->nCount + 1
  413.    enddo
  414.  
  415. RETURN iif( m->nCount = 0, .F., ( m->nTotsq - m->nTot * m->nTot / ;
  416.             m->nCount ) / m->nCount )
  417. *-- EoF: Avar()
  418.  
  419. FUNCTION Aseek
  420. *-----------------------------------------------------------------------
  421. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  422. *-- Date........: 11/02/1993
  423. *-- Notes.......: Binary search of an array for an element of which the
  424. *--               value is Finditem (could be character, numeric or 
  425. *--               date, but of course types of all elements must match).
  426. *--               Works only if array is sorted ascending.  Element found 
  427. *--               is not necessarily the first that matches the value 
  428. *--               sought. To use with array sorted descending, change 
  429. *--               ">" to "<" in the remarked line.
  430. *-- Written for.: dBASE IV, 1.1
  431. *-- Rev. History: 03/01/1992 - original function.
  432. *--               04/21/1992 - Jay Parsons - calling syntax changed
  433. *--               11/02/1993 - now supports Version 2.0 large arrays
  434. *-- Calls.......: AMASK()           Function in ARRAY.PRG
  435. *-- Called by...: Any
  436. *-- Usage.......: Aseek(<cArrayskel>,<xFindItem> )
  437. *-- Example.....: nIndex = Aseek("MyArray [ ,2 ], {01/15/89} )
  438. *-- Returns.....: numeric ( index to place in array where item exists, 
  439. *--               or 0 )
  440. *-- Parameters..: cArrayskel = name of array and optional row/column 
  441. *--                            info
  442. *--               xFindItem  = Item to look for in array. Must be same 
  443. *--                            TYPE as item in array looked for. 
  444. *--                            Numerics are NOT the same as floats for 
  445. *--                            this one.
  446. *-----------------------------------------------------------------------
  447.  
  448.    parameters cArrayskel, xFinditem
  449.    private cArray, cMask, cElem, nHi, nLo, nTrial, cOktype
  450.  
  451.    m->cArray = m->cArrayskel
  452.    if "[" $ m->cArray
  453.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  454.    endif
  455.    m->cArray = trim( ltrim( m->cArray ) )
  456.    m->cMask = Amask( m->cArrayskel, "nTrial" )
  457.    m->cOKType = type( "xFinditem" )
  458.    m->nLo = 1
  459.    m->nHi = iif( val( substr( version(), 11, 3 ) ) < 2, 1170, 65535 )
  460.    do while .t.
  461.       if m->nHi < m->nLo
  462.          m->nTrial = 0
  463.          exit
  464.       else
  465.          m->nTrial = int( ( m->nHi + m->nLo ) / 2 )
  466.       endif
  467.       m->cElem = m->cArray + m->cMask
  468.       m->xNext = type( m->cElem )
  469.       do case
  470.          case m->xNext = "U"
  471.             m->nHi = m->nTrial - 1
  472.          case .not. m->xNext $ m->cOKType
  473.             m->nTrial = 0
  474.             exit
  475.          otherwise
  476.             m->xNext = &cElem.
  477.             do case
  478.                case m->xNext = m->xFindItem
  479.                   exit
  480.                case m->xNext > m->xFindItem   && see notes
  481.                   m->nHi = m->nTrial - 1
  482.                otherwise
  483.                   m->nLo = m->nTrial + 1
  484.             endcase
  485.       endcase
  486.    enddo
  487.  
  488. RETURN m->nTrial
  489. *-- EoF: Aseek
  490.  
  491. FUNCTION Ashuffle
  492. *-----------------------------------------------------------------------
  493. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  494. *-- Date........: 03/01/1992
  495. *-- Notes.......: Random shuffle of elements of an array
  496. *-- Written for.: dBASE IV, 1.1
  497. *-- Rev. History: 03/01/1992 -- Original Release
  498. *-- Calls.......: Amask()           Function in ARRAY.PRG
  499. *--               Arrayrows()       Function in ARRAY.PRG
  500. *--               Arraycols()       Function in ARRAY.PRG
  501. *-- Called by...: Any
  502. *-- Usage.......: AShuffle( "<cArrayskel>" )
  503. *-- Example.....: lX = AShuffle( "aTest[ ,2]" )
  504. *-- Returns.....: .T.
  505. *-- Parameters..: cArrayskel = Name of array, optional row/column 
  506. *--                           designator
  507. *-- Side effects: Rearranges elements of the array
  508. *--               Reseeds random number generator and uses some random 
  509. *--               numbers 
  510. *-----------------------------------------------------------------------
  511.  
  512.    parameters cArrayskel
  513.    private cArray, cMask, m->cElem, cElem, nAt, nRand, nLeft, x1, x2
  514.  
  515.    m->cArray = m->cArrayskel
  516.    if "[" $ m->cArray
  517.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  518.    endif
  519.    m->cArray = trim( ltrim( m->cArray ) )
  520.    m->cMask = Amask( m->cArrayskel, "nAt" )
  521.    if at( ",", m->cMask ) > 0 .and. val( substr( m->cMask, ;
  522.       at( ",", m->cMask ) + 1 ) ) = 0
  523.       m->nLeft = Arraycols( m->cArray )
  524.    else
  525.       m->nLeft = Arrayrows( m->cArray )
  526.    endif
  527.    m->nRand =  rand( -1 )
  528.    do while m->nLeft > 1
  529.       m->nAt = m->nLeft
  530.       m->cElem = m->cArray + m->cMask
  531.       m->x1 = &cElem.
  532.       m->nAt = int( rand() * m->nLeft ) + 1
  533.       m->cElem = m->cArray + m->cMask
  534.       m->x2 = &cElem.
  535.       store m->x1 to &cElem.
  536.       m->nAt = m->nLeft
  537.       m->cElem = m->cArray + m->cMask
  538.       store m->x2 to &cElem.
  539.       m->nLeft = m->nLeft - 1
  540.    enddo
  541.  
  542. RETURN .T.
  543. *-- EoF: Ashuffle()
  544.  
  545. FUNCTION Abubble
  546. *-----------------------------------------------------------------------
  547. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  548. *-- Date........: 04/21/1992
  549. *-- Notes.......: Bubble sort.  This is a slow algorithm, made slower by 
  550. *--               passing the array name as a parameter instead of 
  551. *--               copying the array to one of predefined name.  Its 
  552. *--               primary use is in selecting a few of the highest or 
  553. *--               lowest values from a longer list.  The argument 
  554. *--               "nPasses" gives the number of values guaranteed to 
  555. *--               be in their correct places, in this case the lowest 
  556. *--               values, at the head of the list. Values at other 
  557. *--               places in the list may not have been sorted.
  558. *--               Note: To place the highest values at the head of
  559. *--               the list, change > to < in the remarked line.
  560. *--               What use is it?  Well, a golf handicap is based on
  561. *--               the lowest 10 score differentials of the last 20.
  562. *--               This is the easy way to select them.  Other 
  563. *--               applications include selecting a few invidividuals 
  564. *--               from a large number of candidates based on some 
  565. *--               numeric expression.
  566. *-- Written for.: dBASE IV, 1.1, 1.5
  567. *-- Rev. History: 04/21/1992 -- Original Release
  568. *-- Calls.......: AMASK()           Function in ARRAY.PRG
  569. *--               Arraycols()       Function in ARRAY.PRG
  570. *--               Arrayrows()       Function in ARRAY.PRG
  571. *-- Called by...: Any
  572. *-- Usage.......: BubbleSort("<cArrayskel>" [,<nPass>] )
  573. *-- Example.....: lX = BubbleSort("Test [1,]",10)
  574. *-- Returns.....: .T.
  575. *-- Parameters..: cArrayskel = Name of array, optional row/column 
  576. *--                            designator
  577. *--               nPasses    = number of passes. If you want a complete 
  578. *--                            sort, set this value to the same as 
  579. *--                            length of array, or omit it in 1.5.
  580. *-- Side effects: Rearranges elements of the array
  581. *-----------------------------------------------------------------------
  582.  
  583.    parameters cArrayskel, nPasses
  584.    private nJ, nAt, cArray, cMask, cElem, x1, x2, nP, nPasses, lSwitch, ;
  585.            nOld, nNew
  586.  
  587.    m->cArray = m->cArrayskel
  588.    if "[" $ m->cArray
  589.       m->cArray = left( m->cArray, at( "[", m->cArray ) - 1 )
  590.    endif
  591.    m->cArray = trim( ltrim( m->cArray ) )
  592.    m->cMask = Amask( m->cArrayskel, "nAt" )
  593.    if at( ",", m->cMask ) > 0 .and. val( substr( m->cMask, ;
  594.       at( ",", m->cMask ) + 1 ) ) = 0
  595.       m->nJ = Arraycols( m->cArray )
  596.    else
  597.       m->nJ = Arrayrows( m->cArray )
  598.    endif
  599.    if val( substr( version(), 9, 5 ) ) < 1.5 .or. pcount() > 1
  600.       m->nP = min( m->nPasses, m->nJ )
  601.    else
  602.       m->nP = m->nJ
  603.    endif
  604.    m->nPass = 1
  605.    do while m->nPass <= m->nP
  606.       m->lSwitch = .F.
  607.       m->nOld = m->nJ
  608.       do while .t.
  609.          m->cElem = m->cArray + m->cMask
  610.          m->nAt = m->nOld
  611.          m->x1 = &cElem.
  612.          do while .t.
  613.             m->nNew = m->nOld - 1
  614.             if m->nNew < m->nPass
  615.                exit
  616.             endif
  617.             m->nAt = m->nNew
  618.             m->cElem = m->cArray + m->cMask
  619.             m->x2 = &cElem.
  620.             if m->x1 < m->x2        && see notes
  621.                m->lSwitch = .T.
  622.                m->nAt = m->nOld
  623.                m->cElem = m->cArray + m->cMask
  624.                store m->x2 to &cElem.
  625.                m->nOld = m->nNew
  626.             else
  627.                exit
  628.             endif
  629.          enddo
  630.          m->nAt = m->nOld
  631.          m->cElem = m->cArray + m->cMask
  632.          store m->x1 to &cElem.
  633.          m->nOld = m->nNew
  634.          if m->nOld <= m->nPass
  635.             exit
  636.          endif
  637.       enddo
  638.       if .not. m->lSwitch
  639.          exit
  640.       endif
  641.       m->nPass = m->nPass + 1
  642.    enddo
  643.    
  644. RETURN .T.
  645. *-- EoF: Abubble()
  646.  
  647. FUNCTION ArrayRows
  648. *-----------------------------------------------------------------------
  649. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  650. *-- Date........: 03/24/1993
  651. *-- Notes.......: Number of Rows in an array
  652. *-- Written for.: dBASE IV, 1.1 to 2.0
  653. *-- Rev. History: 03/01/1992 -- Original
  654. *--               03/24/1993 -- Modified to allow up to 65,535 elements
  655. *--                             per dimension, as allowed by version 
  656. *--                             2.0.
  657. *-- Calls.......: None
  658. *-- Called by...: Any
  659. *-- Usage.......: ArrayRows("<aArray>")
  660. *-- Example.....: n = ArrayRows("aTest")
  661. *-- Returns.....: numeric
  662. *-- Parameters..: aArray      = Name of array 
  663. *-----------------------------------------------------------------------
  664.  
  665.    parameters aArray
  666.    private nHi, nLo, nTrial, nDims
  667.  
  668.    m->nLo = 1
  669.    m->nHi = iif( val( substr( version(), 11, 3 ) ) < 2, 1170, 65535 )
  670.    if type( "&aArray.[ 1, 1 ]" ) = "U"
  671.       m->nDims = 1
  672.    else
  673.       m->nDims = 2
  674.    endif
  675.    do while .T.
  676.       m->nTrial = int( ( m->nHi + m->nLo ) / 2 )
  677.       if m->nHi < m->nLo
  678.          exit
  679.       endif
  680.       if m->nDims = 1 .and. type( "&aArray.[ m->nTrial ]" ) = "U" .or.;
  681.          m->nDims = 2 .and. type( "&aArray.[ m->nTrial, 1 ]" ) = "U"
  682.          m->nHi = m->nTrial - 1
  683.       else
  684.          m->nLo = m->nTrial + 1
  685.       endif
  686.    enddo
  687.    
  688. RETURN m->nTrial
  689. *-- EoF: ArrayRows()
  690.  
  691. FUNCTION ArrayCols
  692. *-----------------------------------------------------------------------
  693. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  694. *-- Date........: 03/24/1993
  695. *-- Notes.......: Number of Columns in an array
  696. *-- Written for.: dBASE IV, 1.1 to 2.0
  697. *-- Rev. History: 03/01/1992    Original function
  698. *--               03/24/1993    Modified to allow up to 65,535 elements 
  699. *--                             per dimension, as allowed by dBASE IV 
  700. *--                             Version 2.0
  701. *-- Calls.......: None
  702. *-- Called by...: Any
  703. *-- Usage.......: ArrayCols("<aArray>")
  704. *-- Example.....: n = ArrayCols("aTest")
  705. *-- Returns.....: numeric
  706. *-- Parameters..: aArray      = Name of array 
  707. *-----------------------------------------------------------------------
  708.  
  709.    parameters aArray
  710.    private nHi, nLo, nTrial
  711.  
  712.    m->nLo = 1
  713.    m->nHi = iif( val( substr( version(), 11, 3 ) ) < 2, 1170, 65535 )
  714.    if type( "&aArray.[ 1, 1 ]" ) = "U"
  715.       RETURN 0
  716.    endif
  717.    do while .t.
  718.       m->nTrial = int( ( m->nHi + m->nLo ) / 2 )
  719.       if m->nHi < m->nLo
  720.     exit
  721.       endif
  722.       if type( "&aArray.[ 1, m->nTrial ]" ) = "U"
  723.          m->nHi = m->nTrial - 1
  724.       else
  725.          m->nLo = m->nTrial + 1
  726.       endif
  727.    enddo
  728.  
  729. RETURN m->nTrial
  730. *-- EoF: ArrayCol()
  731.  
  732. FUNCTION ShellSort
  733. *-----------------------------------------------------------------------
  734. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  735. *-- Date........: 11/28/1993
  736. *-- Notes.......: Sort aMyarray[] elements 1 to nNumber, ascending
  737. *--               Note: change < to > in the remarked line for
  738. *--               a descending sort.
  739. *--               If the array is two-dimensional, this sort moves all
  740. *--               elements of each row to whatever row is needed to put
  741. *--               the first column of the array into sorted order.
  742. *--               This routine depends on the elements being copied
  743. *--               into the array "aMyarray" before the sort.  It could,
  744. *--               like the other array functions, accept the name of
  745. *--               the array as a parameter and use it as a macro within,
  746. *--               but performance will be very slow in that case.
  747. *-- Written for.: dBASE IV, 1.1
  748. *-- Rev. History: 03/01/1992 - Original Release
  749. *--               06/15/1993 -  Angus Scott-Fleming [75500,3223]
  750. *--                               sorting a two-dimensional array
  751. *--               11/28/1993 - Jay Parsons.  Combined code for one- and
  752. *--                               two-dimensional arrays to sort either
  753. *-- Calls.......: None
  754. *-- Called by...: Any
  755. *-- Usage.......: ShellSort(<nNumber>,[<nCols>])
  756. *-- Example.....: lX = ShellSort(532)
  757. *-- Returns.....: .T.
  758. *-- Parameters..: nNumber    = Size of array (# of rows )
  759. *--               nCols      = Size of array (# of columns ) [optional]
  760. *-----------------------------------------------------------------------
  761.  
  762.    parameters nNumber, nCols
  763.    private nInterval, nPlace, nI, nJ, xTemp, nX
  764.  
  765.    m->nInterval = m->nNumber
  766.    if type( "aMyarray[ 1, 1 ]" ) = "U"
  767.      do while m->nInterval > 0
  768.        nInterval = int( m->nInterval / 2 )
  769.        nPlace = 1
  770.        do while .T.
  771.          nI = m->nPlace
  772.          nJ = m->nI + m->nInterval
  773.          if m->nJ > m->nNumber
  774.            exit
  775.          endif
  776.          xTemp = aMyarray[ m->nJ ]
  777.          do while m->xTemp < aMyarray[ m->nI ]  && see note
  778.            aMyarray[ m->nJ ] = aMyarray[ m->nI ]
  779.            nJ = m->nI
  780.            nI = m->nI - m->nInterval
  781.            if m->nI < 1
  782.              exit
  783.            endif
  784.          enddo
  785.          aMyarray[ m->nJ ] = m->xTemp
  786.          nPlace = m->nPlace + 1
  787.        enddo
  788.      enddo
  789.    else
  790.      if .not.(type("nCols")="N")
  791.         m->nCols = 1
  792.      endif
  793.      declare xTemp[m->nCols]
  794.      m->nInterval = m->nNumber
  795.      do while m->nInterval > 0
  796.        m->nInterval = int( m->nInterval / 2 )
  797.        m->nPlace = 1
  798.        do while .T.
  799.          m->nI = m->nPlace
  800.          m->nJ = m->nI + m->nInterval
  801.          if m->nJ > m->nNumber
  802.            exit
  803.          endif
  804.          m->nX = 0
  805.          do while m->nX < m->nCols
  806.            m->nX = m->nX + 1
  807.            xTemp[m->nX] = aMyarray[ m->nJ, m->nX ]
  808.          enddo
  809.          do while xTemp[1] < aMyarray[ m->nI, 1 ]  && see note
  810.            m->nX = 0
  811.            do while m->nX < m->nCols
  812.              m->nX = m->nX + 1
  813.              aMyarray[ m->nJ, m->nX ] = aMyarray[ m->nI, m->nX ]
  814.            enddo
  815.            m->nJ = m->nI
  816.            m->nI = m->nI - m->nInterval
  817.            if m->nI < 1
  818.              exit
  819.            endif
  820.          enddo
  821.          m->nX = 0
  822.          do while m->nX < m->nCols
  823.            m->nX = m->nX + 1
  824.            aMyarray[ m->nJ, m->nX ] = xTemp[m->nX]
  825.          enddo
  826.          m->nPlace = m->nPlace + 1
  827.        enddo
  828.      enddo
  829.    endif
  830.  
  831. RETURN .T.
  832. *-- EoF: ShellSort()
  833.  
  834. FUNCTION aPullSort
  835. *-----------------------------------------------------------------------
  836. *-- Programmer..: Kelvin Smith (KELVIN)
  837. *-- Date........: 05/07/1992
  838. *-- Notes.......: Sort aMyarray[] elements 1 to Number, ascending
  839. *--                 Note: change > to < in the remarked line for
  840. *--               a descending sort.
  841. *--               This sorting algorithm, while not as fast as a shell
  842. *--               sort, is fairly simple to understand and considerably
  843. *--               faster than the infamous bubble sort.  Each iteration
  844. *--               pulls the next item in order to the front of the 
  845. *--               unsorted portion of the list.
  846. *--                 This routine depends on the elements being copied
  847. *--               into the array "aMyarray" before the sort.  It could,
  848. *--               like the other array functions, accept the name of
  849. *--               the array as a parameter and use it as a macro within,
  850. *--               but performance will be very slow in that case.
  851. *-- Written for.: dBASE IV, 1.5
  852. *-- Rev. History: 05/07/1992 -- Original Release
  853. *-- Calls.......: None
  854. *-- Called by...: Any
  855. *-- Usage.......: APullSort(<nNumber>)
  856. *-- Example.....: lX = APullSort(532)
  857. *-- Returns.....: .T.
  858. *-- Parameters..: nNumber    = Size of array (# of elements)
  859. *-----------------------------------------------------------------------
  860.  
  861.    parameters nNumber
  862.    private nI, nJ, nSwap, xTemp
  863.  
  864.    m->nI = 1
  865.    do while m->nI < m->nNumber                 && Through the list
  866.       m->nSwap = m->nI
  867.       m->nJ = m->nI + 1
  868.       do while m->nJ <= m->nNumber             && From nI to end of list
  869.          if aMyarray[m->nSwap] > aMyarray[m->nJ] && see note
  870.             m->nSwap = m->nJ                   && Item at nJ is smaller
  871.          endif
  872.          m->nJ = m->nJ + 1
  873.       enddo
  874.       if m->nSwap <> m->nI                     && Found a smaller one
  875.          m->xTemp = aMyarray[m->nSwap]         && Swap it
  876.          aMyarray[m->nSwap] = aMyarray[m->nI]
  877.          aMyarray[m->nI] = m->xTemp
  878.       endif
  879.       m->nI = m->nI + 1
  880.    enddo
  881.  
  882. RETURN .T.
  883. *-- EoF: APullSort()
  884.  
  885. PROCEDURE CmpArray
  886. *-----------------------------------------------------------------------
  887. *-- Programmer..: Werner Borsbach (CIS:100010,2236)
  888. *-- Date........: 02/09/93
  889. *-- Notes.......: Compares two arrays, returns the variable UNCHANGED 
  890. *--               and an array GLEICH with the unchanged-value for every
  891. *--               field in case you have defined them before
  892. *--               calling or have set them public 
  893. *--               Could easy be tranlated to a FUNCTION
  894. *-- Written for.: dBASE IV v1.5
  895. *-- Rev. History: 02/09/1993 Original Release
  896. *--               05/16/1993 modified for use with - modified - 
  897. *--                          aRec2Arr()
  898. *-- Calls.......: None
  899. *-- Called by...: Any
  900. *-- Usage.......: do CmpArray with <Array1>,<Array2>,<Arindex>
  901. *-- Example.....: SatzNr=recno()
  902. *--               aRec2Arr("Test1")
  903. *--               edit SatzNr
  904. *--               goto Satznr
  905. *--               aRec2Arr("Test2")
  906. *--               unchanged=.t.  (or public unchanged)
  907. *--               do Cmparray with "Test1","Test2",fldcount()
  908. *--               ? unchanged
  909. *-- Returns.....: unchanged and Array gleich if predefined
  910. *-- Parameters..: Array1 = Name of first array
  911. *--               Array2 = Name of second array
  912. *--               Arindex= Number of fields
  913. *-----------------------------------------------------------------------
  914.  
  915.    parameter array1,array2,arindex
  916.  
  917.    declare aGleich[m->ArIndex]
  918.    m->lUnChanged=.t.
  919.    m->nOrgInd=m->nArIndex
  920.  
  921.    do while m->nArIndex<>0
  922.       aGleich[m->nArIndex]=iif(&array1.[m->nArIndex]=;
  923.                                &array2.[m->nArIndex],.t.,.f.)
  924.       m->lUnChanged=iif(.not. m->lUnChanged,.f.,;
  925.                                iif(&array1.[m->nArIndex]=;
  926.                                    &array2.[m->nArIndex],.t.,.f.))
  927.       m->nArIndex=m->nArIndex-1
  928.    enddo
  929.  
  930.    m->nArIndex=m->nOrgInd && Originalwert mu· wiederhergestellt werden,
  931.                           && sonst Åbergibt das Programm 0
  932.              
  933. RETURN
  934. *-- EoF: CmpArray
  935.  
  936. FUNCTION ARec2Arr
  937. *-----------------------------------------------------------------------
  938. *-- Programmer..: Bowen Moursund (CIS: 72662,436)
  939. *-- Date........: 05/01/1993
  940. *-- Notes.......: Creates a public array, &aRecord.[n], initialized to 
  941. *--               the record format of the currently selected DBF, 
  942. *--               either blank or filled with the values of the current 
  943. *--               record. Memo fields cannot be copied to an array.
  944. *-- Written for.: dBASE IV v1.5
  945. *-- Rev. History: 05/01/1992 -- Original
  946. *--               05/01/1993 modified by Werner Borsbach 
  947. *--               (CIS: 100010,2236) - name of array is to be chosen 
  948. *--               when the function is called so that one now can 
  949. *--               create multiple arrays and compare them.
  950. *-- Calls.......: None
  951. *-- Called by...: Any
  952. *-- Usage.......: Arec2Arr(<aRecord>,[<lBlank>])
  953. *-- Example.....: lSuccess = Arec2Arr("data")
  954. *-- Returns.....: .T. if succesful, .F. if not.
  955. *-- Parameters..: aRecord = name of array
  956. *--               lBlank  = whether or not to create an empty array.
  957. *--                         .T. = blank
  958. *--                         .F. = current record values
  959. *-- Side effects: Creates a public array, &aRecord.[n]. It will destroy
  960. *--               an existing array of that name 
  961. *-----------------------------------------------------------------------
  962.  
  963.    parameters aRecord,lBlank
  964.    private lSuccess,lDbf,cFieldName,nFieldNumb,nNumFields
  965.  
  966.    m->lSuccess = .f.
  967.    m->lDBF = ( "" # dbf() )
  968.    if ((m->lDBF .and. m->lBlank) .or. (.not. m->lBlank .and. m->lDBF ;
  969.       .and. .not. eof()))
  970.       release &aRecord.
  971.       m->nNumFields = fldcount()
  972.       public array &aRecord.[m->nNumFields]
  973.       if m->lBlank
  974.          goto bottom
  975.          skip         && phantom record
  976.          m->nFieldNumb=1
  977.          do while m->nFieldNumb <= m->nNumFields
  978.             m->cFieldName = field(m->nFieldNumb)
  979.             store &cFieldName. to &aRecord.[m->nFieldNumb] 
  980.             m->nFieldNumb = m->nFieldNumb + 1
  981.          enddo
  982.       else
  983.          copy to array &aRecord. next 1
  984.       endif
  985.       m->lSuccess = .t.
  986.    endif
  987.  
  988. RETURN m->lSuccess
  989. *-- EoF: Arec2Arr()
  990.  
  991. *-----------------------------------------------------------------------
  992. *-- The following are routines to manipulate a stack.
  993. *--
  994. *-- stack:      INDEX   STACK ELEMENTS
  995. *--                   |--------------------|
  996. *--               1   | Size of Stack      |
  997. *--                   |--------------------|
  998. *--               2   | Top of Stack (TOS) |
  999. *--                   |--------------------|
  1000. *--               3   | First Element      |
  1001. *--                   |--------------------|
  1002. *--                   |                    |
  1003. *--
  1004. *--                   |                    |
  1005. *--                   |--------------------|
  1006. *--              TOS  | Top Element        |
  1007. *--                   |--------------------|
  1008. *--
  1009. *-----------------------------------------------------------------------
  1010.  
  1011. FUNCTION StackNew
  1012. *-----------------------------------------------------------------------
  1013. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1014. *-- Date........: 07/15/93
  1015. *-- Notes.......: Creates a new stack. This is not a true stack since it
  1016. *--               is limited in size.
  1017. *--
  1018. *--               &cName.[1] = maximum size of stack
  1019. *--               &cName.[2] = top of stack pointer value
  1020. *--
  1021. *--               For large stacks it may be necessary to increase
  1022. *--               memory variable space (for the other memvars)
  1023. *-- Written for.: dBASE IV, v2.0
  1024. *-- Rev. History: 07/15/1993 - Original Release
  1025. *-- Calls.......: None
  1026. *-- Called by...: Any
  1027. *-- Usage.......: ? StackNew(<cName>, <nSize>)
  1028. *-- Example.....: lError = StackNew("stack1",100)
  1029. *-- Returns.....: .t. if stack created, else .f.
  1030. *-- Parameters..: cName = name of stack
  1031. *--               nSize = size of stack
  1032. *-- Side Effect.: Changes setting for ON ERROR
  1033. *-----------------------------------------------------------------------
  1034.  
  1035.    parameters cName, nSize
  1036.  
  1037.    private m->lRet
  1038.  
  1039.    m->lRet = .t.
  1040.    on error m->lRet = .f.
  1041.    public array &cName.[nSize+2]   && fails if size too big for version
  1042.    on error
  1043.    if m->lRet
  1044.       store nSize to &cName.[1]    && initialize stack header info
  1045.       store 3 to &cName.[2] 
  1046.    endif
  1047.  
  1048. RETURN m->lRet
  1049. *-- EoF: StackNew()
  1050.  
  1051. FUNCTION StackEmpty
  1052. *-----------------------------------------------------------------------
  1053. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1054. *-- Date........: 07/16/1993
  1055. *-- Notes.......: Checks if stack is empty.
  1056. *-- Written for.: dBASE IV, 2.0
  1057. *-- Rev. History: 06/16/1993 -- Original
  1058. *-- Calls.......: None
  1059. *-- Called by...: Any
  1060. *-- Usage.......: StackEmpty(<cName>)
  1061. *-- Example.....: lError = StackEmpty("mystack")
  1062. *-- Returns.....: .t. if stack is empty, .f. otherwise
  1063. *-- Parameters..: cName = name of stack
  1064. *-----------------------------------------------------------------------
  1065.  
  1066.    parameters cName
  1067.  
  1068. RETURN (&cName.[2] <= 3)
  1069. *-- EoF: StackEmpty()
  1070.  
  1071. FUNCTION StackFull
  1072. *-----------------------------------------------------------------------
  1073. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1074. *-- Date........: 07/16/1993
  1075. *-- Notes.......: Stack is full if top_of_stack pointer is one beyond the
  1076. *--               stack size.
  1077. *-- Written for.: dBASE IV, 2.0
  1078. *-- Rev. History: 07/16/1993 -- Original
  1079. *-- Calls.......: None
  1080. *-- Called by...: StackPush()
  1081. *-- Usage.......: StackFull(<cName>)
  1082. *-- Example.....: lError = StackFull("mystack")
  1083. *-- Returns.....: .t. if stack is full, .f. otherwise
  1084. *-- Parameters..: cName = name of stack
  1085. *-----------------------------------------------------------------------
  1086.  
  1087.    parameters cName
  1088.  
  1089. RETURN (&cName.[2] >= &cName.[1]+3)
  1090. *-- EoF: StackFull()
  1091.  
  1092. FUNCTION StackPush
  1093. *-----------------------------------------------------------------------
  1094. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1095. *-- Date........: 07/17/1993
  1096. *-- Notes.......: Adds an element to the stack. Stack elements can be of
  1097. *--               any type.
  1098. *-- Written for.: dBASE IV, 2.0
  1099. *-- Rev. History: 07/17/1993 -- Original
  1100. *-- Calls.......: StackFull()
  1101. *-- Called by...: Any
  1102. *-- Usage.......: StackPush(<cName>,<xElement>)
  1103. *-- Example.....: lError = StackPush("mystack", cWord)
  1104. *-- Returns.....: .t. if the element was added (stack must not be full)
  1105. *-- Parameters..: cName    = name of stack
  1106. *--               xElement = element to add to stack
  1107. *-----------------------------------------------------------------------
  1108.  
  1109.    parameters cName, xElement
  1110.    private lRet, nTOS
  1111.  
  1112.    if .not. StackFull(m->cName)
  1113.        m->nToS = &cName.[2]                  && get top of stack
  1114.        store m->xElement to &cName.[m->nToS] && add element
  1115.        store m->nToS+1 to &cName.[2]         && increment top of 
  1116.                                              && stack pointer
  1117.        m->lRet = .t.
  1118.    else
  1119.         m->lRet = .f.
  1120.    endif
  1121.  
  1122. RETURN m->lRet
  1123. *-- EoF: StackPush()
  1124.  
  1125. FUNCTION StackPop
  1126. *-----------------------------------------------------------------------
  1127. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1128. *-- Date........: 07/16/1993
  1129. *-- Notes.......: Remove an element from the stack (if stack not empty).
  1130. *-- Written for.: dBASE IV, 2.0
  1131. *-- Rev. History: 07/16/1993 -- Original
  1132. *-- Calls.......: StackEmpty()
  1133. *-- Called by...: Any
  1134. *-- Usage.......: StackPop(<cName>, <xElement>)
  1135. *-- Example.....: lError = StackPop("mystack", cWord)
  1136. *-- Returns.....: .t. if an element was remove, .f. if stack was empty
  1137. *-- Parameters..: cName    = name of stack
  1138. *--               xElement = receptacle for the top element
  1139. *-----------------------------------------------------------------------
  1140.  
  1141.    parameters cName, xElement
  1142.    private lRet
  1143.  
  1144.    if .not. StackEmpty(m->cName)
  1145.       store &cName.[2]-1 to &cName.[2]   && decrement stack pointer
  1146.       m->xElement = &cName.[&cName.[2]]  && pop element
  1147.       m->lRet = .t.
  1148.    else
  1149.       m->lRet = .f.
  1150.    endif
  1151.  
  1152. RETURN  m->lRet
  1153. *-- EoF: StackPop()
  1154.  
  1155. FUNCTION StackTop
  1156. *-----------------------------------------------------------------------
  1157. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1158. *-- Date........: 07/16/1993
  1159. *-- Notes.......: Assigns element on top of stack without removing it.
  1160. *-- Written for.: dBASE IV, 2.0
  1161. *-- Rev. History: 07/16/1993 -- Original
  1162. *-- Calls.......: StackEmpty()
  1163. *-- Called by...: Any
  1164. *-- Usage.......: StackTop(<cName>,<xElement>)
  1165. *-- Example.....: lError = StackTop("mystack", cWord)
  1166. *-- Returns.....: .t. if stack was not empty, else .f.
  1167. *-- Parameters..: cName    = name of stack
  1168. *--               xElement = receptacle for top element on stack
  1169. *-----------------------------------------------------------------------
  1170.  
  1171.    parameters cName, xElement
  1172.    private lRet
  1173.  
  1174.    if .not. StackEmpty(cName)
  1175.       m->xElement = &cName.[&cName.[2]-1]        && show top element
  1176.       m->lRet = .t.                              && leave top of stack
  1177.    else                                          && pointer alone
  1178.       m->lRet = .f.
  1179.    endif
  1180.  
  1181. RETURN  m->lRet
  1182. *-- EoF: StackTop()
  1183.  
  1184. PROCEDURE StackDelete
  1185. *-----------------------------------------------------------------------
  1186. *-- Programmer..: Frank A. Deviney, Jr. (CIS: 72357,345)
  1187. *-- Date........: 07/17/1993
  1188. *-- Notes.......: Releases memory held by a stack
  1189. *-- Written for.: dBASE IV, 2.0
  1190. *-- Rev. History: 07/17/1993 -- Original Release
  1191. *-- Calls.......: None
  1192. *-- Called by...: Any
  1193. *-- Usage.......: StackDelete with <cName>
  1194. *-- Example.....: do StackDelete with "mystack"
  1195. *-- Returns.....: n/a
  1196. *-- Parameters..: cName = name of stack
  1197. *-----------------------------------------------------------------------
  1198.  
  1199.    parameters cName
  1200.  
  1201.    release &cName.
  1202.  
  1203. RETURN
  1204. *-- EoP: StackDelete
  1205.  
  1206. *-----------------------------------------------------------------------
  1207. *-- EoP: ARRAY.PRG
  1208. *-----------------------------------------------------------------------
  1209.  
  1210.